home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / BUTTER~1.CLS < prev    next >
Text File  |  1997-06-14  |  4KB  |  129 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CButterFly"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Implements IAnimation
  13.  
  14. Private fRunning As Boolean
  15. Private objCanvas As Object
  16.  
  17. Public Enum eeErrorButterFly
  18.     eeBaseButterFly = 13010     ' CButterfly
  19. End Enum
  20.  
  21. Private Sub Class_Terminate()
  22.     Set objCanvas = Nothing
  23. End Sub
  24.  
  25. Private Property Let IAnimation_Running(fRunningA As Boolean)
  26.     fRunning = fRunningA
  27.     If fRunning Then Draw
  28. End Property
  29. Private Property Get IAnimation_Running() As Boolean
  30.     IAnimation_Running = fRunning
  31. End Property
  32.  
  33. Private Property Get IAnimation_Canvas() As Object
  34.     Set IAnimation_Canvas = objCanvas
  35. End Property
  36.  
  37. Private Property Set IAnimation_Canvas(objCanvasA As Object)
  38.     Set objCanvas = objCanvasA
  39. End Property
  40.  
  41. Private Sub Draw()
  42.     
  43.     fRunning = True
  44.     Const PI = 3.1415
  45.  
  46.     Dim x As Single, y As Single, theta As Single
  47.     Dim xx As Single, yy As Single, R As Single
  48.     Dim mulxy As Single, addxy As Single
  49.     Dim powr As Single, divt As Single
  50.     Dim mult As Single, mulc As Single
  51.     Dim incr As Single, muloop As Single
  52.     Dim f As Boolean, clr As Long
  53.       
  54.     ' Initialize variables
  55.     mulxy = 24#     ' Controls size
  56.     powr = 5#       ' Controls some aspects of shape
  57.     divt = 40#      ' Controls density
  58.     mult = 4#       ' Helps make butterfly shape
  59.     mulc = 2#       ' Helps make butterfly shape
  60.     incr = 0.05     ' Controls roundness
  61.     muloop = 50#    ' Controls iterations and density
  62.  
  63.     ' Make it square
  64.     If objCanvas.Width < objCanvas.Height Then
  65.         objCanvas.Width = objCanvas.Height
  66.     Else
  67.         objCanvas.Height = objCanvas.Width
  68.     End If
  69.     ' Set coordinate system
  70.     objCanvas.ScaleLeft = -100#
  71.     objCanvas.ScaleTop = -110#
  72.     objCanvas.ScaleWidth = 200#
  73.     objCanvas.ScaleHeight = 200#
  74.  
  75.     Do While fRunning
  76.         ' Draw in random color or erase with background
  77.         f = Not f
  78.         If f Then
  79.             clr = QBColor(MRandom.Random(1, 15))
  80.         Else
  81.             clr = objCanvas.BackColor
  82.         End If
  83.         ' Draw shape
  84.         For theta = 0# To muloop * PI Step incr
  85.             
  86.             R = Exp(Cos(theta)) - _
  87.                 mulc * Cos(mult * theta) + _
  88.                 Sin(theta / divt) ^ powr
  89.             x = R * Sin(theta)
  90.             y = R * Cos(theta)
  91.             xx = -((x * mulxy) + addxy)
  92.             yy = -((y * mulxy) + addxy)
  93.             If theta = 0# Then
  94.                ' Move to center without drawing
  95.                objCanvas.CurrentX = xx
  96.                objCanvas.CurrentY = yy
  97.             Else
  98.                 objCanvas.Line -(xx, yy), clr
  99.             End If
  100.             theta = theta + incr
  101.             DoEvents
  102.             If Not fRunning Then Exit Sub
  103.         Next
  104.     Loop
  105.         
  106. End Sub
  107.  
  108. #If fComponent = 0 Then
  109. Private Sub ErrRaise(e As Long)
  110.     Dim sText As String, sSource As String
  111.     If e > 1000 Then
  112.         sSource = App.ExeName & ".ButterFly"
  113.         Select Case e
  114.         Case eeBaseButterFly
  115.             BugAssert True
  116.        ' Case ee...
  117.        '     Add additional errors
  118.         End Select
  119.         Err.Raise COMError(e), sSource, sText
  120.     Else
  121.         ' Raise standard Visual Basic error
  122.         sSource = App.ExeName & ".VBError"
  123.         Err.Raise e, sSource
  124.     End If
  125. End Sub
  126. #End If
  127.  
  128.  
  129.